home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Camelot / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].zip / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].adf / XLisp-Stat / menus.lsp < prev    next >
Lisp/Scheme  |  1990-05-25  |  6KB  |  181 lines
  1. ;;;;
  2. ;;;;
  3. ;;;; menus.lsp Menus for the Macintosh
  4. ;;;; XLISP-STAT 2.0 Copyright (c) 1988, by Luke Tierney
  5. ;;;;    All Rights Reserved
  6. ;;;;    Permission is granted for unrestricted non-commercial use
  7. ;;;; Additions to
  8. ;;;; Xlisp 2.0 Copyright (c) 1985, 1987 by David Michael Betz
  9. ;;;;
  10. ;;;;
  11.  
  12. (provide "menus")
  13.  
  14. ;;;;
  15. ;;;; Editing Methods
  16. ;;;;
  17.  
  18. (defmeth edit-window-proto :edit-selection ()
  19.     (send (send edit-window-proto :new)
  20.           :paste-stream (send self :selection-stream)))
  21.  
  22. (defmeth edit-window-proto :eval-selection ()
  23.   (let ((s (send self :selection-stream)))
  24.     (do ((expr (read s nil '*eof*) (read s nil '*eof*)))
  25.         ((eq expr '*eof*))
  26.       (eval expr))))
  27.  
  28. (let ((last-string ""))
  29.   (defmeth edit-window-proto :find ()
  30. "Method args: ()
  31. Opens dialog to get string to find and finds it. Beeps if not found."
  32.     (let ((s (get-string-dialog "String to find:" :initial last-string)))
  33.       (when s
  34.           (if (stringp s) (setq last-string s))
  35.           (unless (and (stringp s) (send self :find-string s))
  36.                   (sysbeep)))))
  37.   (defmeth edit-window-proto :find-again ()
  38.     (unless (and (stringp last-string) 
  39.                  (< 0 (length last-string))
  40.                  (send self :find-string last-string))
  41.             (sysbeep))))
  42.                   
  43. ;;;;
  44. ;;;; General Menu Methods and Functions
  45. ;;;;
  46. (defmeth menu-proto :find-item (str)
  47. "Method args: (str)
  48. Finds and returns menu item with tile STR."
  49.   (dolist (item (send self :items))
  50.     (if (string-equal str (send item :title)) (return item))))
  51.  
  52. (defun find-menu (title)
  53. "Args: (title)
  54. Finds and returns menu in the menu bar with title TITLE."
  55.   (dolist (i *hardware-objects*)
  56.           (let ((object (nth 2 i)))
  57.             (if (and (kind-of-p object menu-proto) 
  58.                      (send object :installed-p) 
  59.                      (string-equal (string title) (send object :title)))
  60.                 (return object)))))
  61.  
  62. (defun set-menu-bar (menus)
  63. "Args (menus)
  64. Makes the list MENUS the current menu bar."
  65.   (dolist (i *hardware-objects*)
  66.           (let ((object (nth 2 i)))
  67.             (if (kind-of-p object menu-proto) (send object :remove))))
  68.   (dolist (i menus) (send i :allocate) (send i :install)))
  69.   
  70. ;;;;
  71. ;;;; Apple Menu
  72. ;;;;
  73. (defvar *apple-menu* (send apple-menu-proto :new (string #\apple)))
  74. (send *apple-menu* :append-items 
  75.   (send menu-item-proto :new "About XLISP-STAT" :action 'about-xlisp-stat)
  76.   (send dash-item-proto :new))
  77.  
  78. ;;;;
  79. ;;;; File Menu
  80. ;;;;
  81. (defvar *file-menu* (send menu-proto :new "File"))
  82.  
  83. (defproto file-edit-item-proto '(message) '() menu-item-proto)
  84.  
  85. (defmeth file-edit-item-proto :isnew (title message &rest args)
  86.   (setf (slot-value 'message) message)
  87.   (apply #'call-next-method title args))
  88.   
  89. (defmeth file-edit-item-proto :do-action ()
  90.   (send (front-window) (slot-value 'message)))
  91.   
  92. (defmeth file-edit-item-proto :update ()
  93.   (send self :enabled (kind-of-p (front-window) edit-window-proto)))
  94.   
  95. (send *file-menu* :append-items 
  96.   (send menu-item-proto :new "Load" :key #\L :action
  97.     #'(lambda ()
  98.       (let ((f (open-file-dialog t)))
  99.         (when f (load f) (format t "; finished loading ~s~%" f)))))
  100.   (send dash-item-proto :new)
  101.   (send menu-item-proto :new "New Edit" :key #\N
  102.         :action #'(lambda () (send edit-window-proto :new)))
  103.   (send menu-item-proto :new "Open Edit" :key #\O
  104.         :action #'(lambda () (send edit-window-proto :new :bind-to-file t)))
  105.   (send dash-item-proto :new)
  106.   (send file-edit-item-proto :new "Save Edit" :save :key #\S)
  107.   (send file-edit-item-proto :new "Save Edit As" :save-as)
  108.   (send file-edit-item-proto :new "Save Edit Copy" :save-copy)
  109.   (send file-edit-item-proto :new "Revert Edit" :revert)
  110.   (send dash-item-proto :new)
  111.   (send menu-item-proto :new "Quit" :key #\Q :action 'exit))
  112.  
  113. ;;;;
  114. ;;;; Edit Menu
  115. ;;;;
  116. (defproto edit-menu-item-proto '(item message) '() menu-item-proto)
  117.  
  118. (defmeth edit-menu-item-proto :isnew (title item message &rest args)
  119.   (setf (slot-value 'item) item)
  120.   (setf (slot-value 'message) message)
  121.   (apply #'call-next-method title args))
  122.   
  123. (defmeth edit-menu-item-proto :do-action ()
  124.   (unless (system-edit (slot-value 'item))
  125.           (let ((window (front-window)))
  126.             (if window (send window (slot-value 'message))))))
  127.           
  128. (defvar *edit-menu* (send menu-proto :new "Edit"))
  129. (send *edit-menu* :append-items
  130.   (send edit-menu-item-proto :new "Undo" 0 :undo :enabled nil)
  131.   (send dash-item-proto :new)
  132.   (send edit-menu-item-proto :new "Cut" 2 :cut-to-clip :key #\X)
  133.   (send edit-menu-item-proto :new "Copy" 3 :copy-to-clip :key #\C)
  134.   (send edit-menu-item-proto :new "Paste" 4 :paste-from-clip :key #\V)
  135.   (send edit-menu-item-proto :new "Clear" 5 :clear :enabled nil)
  136.   (send dash-item-proto :new)
  137.   (send menu-item-proto :new "Copy-Paste" :key #\/ :action
  138.     #'(lambda () 
  139.       (let ((window (front-window)))
  140.         (when  window
  141.               (send window :copy-to-clip)
  142.               (send window :paste-from-clip)))))
  143.   (send dash-item-proto :new)
  144.   (send menu-item-proto :new "Find ..." :key #\F :action
  145.     #'(lambda () 
  146.       (let ((window (front-window))) 
  147.         (if window (send window :find)))))
  148.   (send menu-item-proto :new "Find Again" :key #\A :action
  149.     #'(lambda () 
  150.       (let ((window (front-window))) 
  151.         (if window (send window :find-again)))))
  152.   (send dash-item-proto :new)
  153.   (send menu-item-proto :new "Edit Selection" :action
  154.     #'(lambda () (send (front-window) :edit-selection)))
  155.   (send menu-item-proto :new "Eval Selection" :key #\E :action
  156.     #'(lambda () (send (front-window) :eval-selection))))
  157.  
  158. ;;;;
  159. ;;;; Command Menu
  160. ;;;;
  161. (defvar *command-menu* (send menu-proto :new "Command"))
  162. (send *command-menu* :append-items
  163.   (send menu-item-proto :new "Show XLISP-STAT"
  164.                         :action #'(lambda () (send *listener* :show-window)))
  165.   (send dash-item-proto :new)
  166.   (send menu-item-proto :new "Clean Up" :key #\, :action #'clean-up)
  167.   (send menu-item-proto :new "Toplevel" :key #\. :action #'top-level)
  168.   (send dash-item-proto :new)
  169.   (let ((item (send menu-item-proto :new "Dribble")))
  170.     (send item :action 
  171.         #'(lambda () 
  172.             (cond
  173.               ((send item :mark) (dribble) (send item :mark nil))
  174.               (t (let ((f (set-file-dialog "Dribble file:")))
  175.                    (when f
  176.                          (dribble f)
  177.                          (send item :mark t)))))))
  178.     item))
  179.  
  180. (defconstant *standard-menu-bar* 
  181.              (list *apple-menu* *file-menu* *edit-menu* *command-menu*))